home *** CD-ROM | disk | FTP | other *** search
/ Stone Design / Stone Design.iso / Stone_Friends / Wave / WavesWorld / Source / Libraries / tcl7.4b3 / tclProc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-12-17  |  16.1 KB  |  630 lines

  1. /* 
  2.  * tclProc.c --
  3.  *
  4.  *    This file contains routines that implement Tcl procedures,
  5.  *    including the "proc" and "uplevel" commands.
  6.  *
  7.  * Copyright (c) 1987-1993 The Regents of the University of California.
  8.  * Copyright (c) 1994 Sun Microsystems, Inc.
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  */
  13.  
  14. #ifndef lint
  15. static char sccsid[] = "@(#) tclProc.c 1.70 94/12/17 16:14:29";
  16. #endif
  17.  
  18. #include "tclInt.h"
  19.  
  20. /*
  21.  * Forward references to procedures defined later in this file:
  22.  */
  23.  
  24. static void    CleanupProc _ANSI_ARGS_((Proc *procPtr));
  25. static  int    InterpProc _ANSI_ARGS_((ClientData clientData,
  26.             Tcl_Interp *interp, int argc, char **argv));
  27. static  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
  28.  
  29. /*
  30.  *----------------------------------------------------------------------
  31.  *
  32.  * Tcl_ProcCmd --
  33.  *
  34.  *    This procedure is invoked to process the "proc" Tcl command.
  35.  *    See the user documentation for details on what it does.
  36.  *
  37.  * Results:
  38.  *    A standard Tcl result value.
  39.  *
  40.  * Side effects:
  41.  *    A new procedure gets created.
  42.  *
  43.  *----------------------------------------------------------------------
  44.  */
  45.  
  46.     /* ARGSUSED */
  47. int
  48. Tcl_ProcCmd(dummy, interp, argc, argv)
  49.     ClientData dummy;            /* Not used. */
  50.     Tcl_Interp *interp;            /* Current interpreter. */
  51.     int argc;                /* Number of arguments. */
  52.     char **argv;            /* Argument strings. */
  53. {
  54.     register Interp *iPtr = (Interp *) interp;
  55.     register Proc *procPtr;
  56.     int result, argCount, i;
  57.     char **argArray = NULL;
  58.     Arg *lastArgPtr;
  59.     register Arg *argPtr = NULL;    /* Initialization not needed, but
  60.                      * prevents compiler warning. */
  61.  
  62.     if (argc != 4) {
  63.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  64.         " name args body\"", (char *) NULL);
  65.     return TCL_ERROR;
  66.     }
  67.  
  68.     procPtr = (Proc *) ckalloc(sizeof(Proc));
  69.     procPtr->iPtr = iPtr;
  70.     procPtr->refCount = 1;
  71.     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
  72.     strcpy(procPtr->command, argv[3]);
  73.     procPtr->argPtr = NULL;
  74.  
  75.     /*
  76.      * Break up the argument list into argument specifiers, then process
  77.      * each argument specifier.
  78.      */
  79.  
  80.     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
  81.     if (result != TCL_OK) {
  82.     goto procError;
  83.     }
  84.     lastArgPtr = NULL;
  85.     for (i = 0; i < argCount; i++) {
  86.     int fieldCount, nameLength, valueLength;
  87.     char **fieldValues;
  88.  
  89.     /*
  90.      * Now divide the specifier up into name and default.
  91.      */
  92.  
  93.     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  94.         &fieldValues);
  95.     if (result != TCL_OK) {
  96.         goto procError;
  97.     }
  98.     if (fieldCount > 2) {
  99.         ckfree((char *) fieldValues);
  100.         Tcl_AppendResult(interp,
  101.             "too many fields in argument specifier \"",
  102.             argArray[i], "\"", (char *) NULL);
  103.         result = TCL_ERROR;
  104.         goto procError;
  105.     }
  106.     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  107.         ckfree((char *) fieldValues);
  108.         Tcl_AppendResult(interp, "procedure \"", argv[1],
  109.             "\" has argument with no name", (char *) NULL);
  110.         result = TCL_ERROR;
  111.         goto procError;
  112.     }
  113.     nameLength = strlen(fieldValues[0]) + 1;
  114.     if (fieldCount == 2) {
  115.         valueLength = strlen(fieldValues[1]) + 1;
  116.     } else {
  117.         valueLength = 0;
  118.     }
  119.     argPtr = (Arg *) ckalloc((unsigned)
  120.         (sizeof(Arg) - sizeof(argPtr->name) + nameLength
  121.         + valueLength));
  122.     if (lastArgPtr == NULL) {
  123.         procPtr->argPtr = argPtr;
  124.     } else {
  125.         lastArgPtr->nextPtr = argPtr;
  126.     }
  127.     lastArgPtr = argPtr;
  128.     argPtr->nextPtr = NULL;
  129.     strcpy(argPtr->name, fieldValues[0]);
  130.     if (fieldCount == 2) {
  131.         argPtr->defValue = argPtr->name + nameLength;
  132.         strcpy(argPtr->defValue, fieldValues[1]);
  133.     } else {
  134.         argPtr->defValue = NULL;
  135.     }
  136.     ckfree((char *) fieldValues);
  137.     }
  138.  
  139.     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
  140.         ProcDeleteProc);
  141.     ckfree((char *) argArray);
  142.     return TCL_OK;
  143.  
  144.     procError:
  145.     ckfree(procPtr->command);
  146.     while (procPtr->argPtr != NULL) {
  147.     argPtr = procPtr->argPtr;
  148.     procPtr->argPtr = argPtr->nextPtr;
  149.     ckfree((char *) argPtr);
  150.     }
  151.     ckfree((char *) procPtr);
  152.     if (argArray != NULL) {
  153.     ckfree((char *) argArray);
  154.     }
  155.     return result;
  156. }
  157.  
  158. /*
  159.  *----------------------------------------------------------------------
  160.  *
  161.  * TclGetFrame --
  162.  *
  163.  *    Given a description of a procedure frame, such as the first
  164.  *    argument to an "uplevel" or "upvar" command, locate the
  165.  *    call frame for the appropriate level of procedure.
  166.  *
  167.  * Results:
  168.  *    The return value is -1 if an error occurred in finding the
  169.  *    frame (in this case an error message is left in interp->result).
  170.  *    1 is returned if string was either a number or a number preceded
  171.  *    by "#" and it specified a valid frame.  0 is returned if string
  172.  *    isn't one of the two things above (in this case, the lookup
  173.  *    acts as if string were "1").  The variable pointed to by
  174.  *    framePtrPtr is filled in with the address of the desired frame
  175.  *    (unless an error occurs, in which case it isn't modified).
  176.  *
  177.  * Side effects:
  178.  *    None.
  179.  *
  180.  *----------------------------------------------------------------------
  181.  */
  182.  
  183. int
  184. TclGetFrame(interp, string, framePtrPtr)
  185.     Tcl_Interp *interp;        /* Interpreter in which to find frame. */
  186.     char *string;        /* String describing frame. */
  187.     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
  188.                  * if global frame indicated). */
  189. {
  190.     register Interp *iPtr = (Interp *) interp;
  191.     int curLevel, level, result;
  192.     CallFrame *framePtr;
  193.  
  194.     /*
  195.      * Parse string to figure out which level number to go to.
  196.      */
  197.  
  198.     result = 1;
  199.     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
  200.     if (*string == '#') {
  201.     if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
  202.         return -1;
  203.     }
  204.     if (level < 0) {
  205.         levelError:
  206.         Tcl_AppendResult(interp, "bad level \"", string, "\"",
  207.             (char *) NULL);
  208.         return -1;
  209.     }
  210.     } else if (isdigit(UCHAR(*string))) {
  211.     if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
  212.         return -1;
  213.     }
  214.     level = curLevel - level;
  215.     } else {
  216.     level = curLevel - 1;
  217.     result = 0;
  218.     }
  219.  
  220.     /*
  221.      * Figure out which frame to use, and modify the interpreter so
  222.      * its variables come from that frame.
  223.      */
  224.  
  225.     if (level == 0) {
  226.     framePtr = NULL;
  227.     } else {
  228.     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  229.         framePtr = framePtr->callerVarPtr) {
  230.         if (framePtr->level == level) {
  231.         break;
  232.         }
  233.     }
  234.     if (framePtr == NULL) {
  235.         goto levelError;
  236.     }
  237.     }
  238.     *framePtrPtr = framePtr;
  239.     return result;
  240. }
  241.  
  242. /*
  243.  *----------------------------------------------------------------------
  244.  *
  245.  * Tcl_UplevelCmd --
  246.  *
  247.  *    This procedure is invoked to process the "uplevel" Tcl command.
  248.  *    See the user documentation for details on what it does.
  249.  *
  250.  * Results:
  251.  *    A standard Tcl result value.
  252.  *
  253.  * Side effects:
  254.  *    See the user documentation.
  255.  *
  256.  *----------------------------------------------------------------------
  257.  */
  258.  
  259.     /* ARGSUSED */
  260. int
  261. Tcl_UplevelCmd(dummy, interp, argc, argv)
  262.     ClientData dummy;            /* Not used. */
  263.     Tcl_Interp *interp;            /* Current interpreter. */
  264.     int argc;                /* Number of arguments. */
  265.     char **argv;            /* Argument strings. */
  266. {
  267.     register Interp *iPtr = (Interp *) interp;
  268.     int result;
  269.     CallFrame *savedVarFramePtr, *framePtr;
  270.  
  271.     if (argc < 2) {
  272.     uplevelSyntax:
  273.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  274.         " ?level? command ?arg ...?\"", (char *) NULL);
  275.     return TCL_ERROR;
  276.     }
  277.  
  278.     /*
  279.      * Find the level to use for executing the command.
  280.      */
  281.  
  282.     result = TclGetFrame(interp, argv[1], &framePtr);
  283.     if (result == -1) {
  284.     return TCL_ERROR;
  285.     }
  286.     argc -= (result+1);
  287.     if (argc == 0) {
  288.     goto uplevelSyntax;
  289.     }
  290.     argv += (result+1);
  291.  
  292.     /*
  293.      * Modify the interpreter state to execute in the given frame.
  294.      */
  295.  
  296.     savedVarFramePtr = iPtr->varFramePtr;
  297.     iPtr->varFramePtr = framePtr;
  298.  
  299.     /*
  300.      * Execute the residual arguments as a command.
  301.      */
  302.  
  303.     if (argc == 1) {
  304.     result = Tcl_Eval(interp, argv[0]);
  305.     } else {
  306.     char *cmd;
  307.  
  308.     cmd = Tcl_Concat(argc, argv);
  309.     result = Tcl_Eval(interp, cmd);
  310.     ckfree(cmd);
  311.     }
  312.     if (result == TCL_ERROR) {
  313.     char msg[60];
  314.     sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
  315.     Tcl_AddErrorInfo(interp, msg);
  316.     }
  317.  
  318.     /*
  319.      * Restore the variable frame, and return.
  320.      */
  321.  
  322.     iPtr->varFramePtr = savedVarFramePtr;
  323.     return result;
  324. }
  325.  
  326. /*
  327.  *----------------------------------------------------------------------
  328.  *
  329.  * TclFindProc --
  330.  *
  331.  *    Given the name of a procedure, return a pointer to the
  332.  *    record describing the procedure.
  333.  *
  334.  * Results:
  335.  *    NULL is returned if the name doesn't correspond to any
  336.  *    procedure.  Otherwise the return value is a pointer to
  337.  *    the procedure's record.
  338.  *
  339.  * Side effects:
  340.  *    None.
  341.  *
  342.  *----------------------------------------------------------------------
  343.  */
  344.  
  345. Proc *
  346. TclFindProc(iPtr, procName)
  347.     Interp *iPtr;        /* Interpreter in which to look. */
  348.     char *procName;        /* Name of desired procedure. */
  349. {
  350.     Tcl_HashEntry *hPtr;
  351.     Command *cmdPtr;
  352.  
  353.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
  354.     if (hPtr == NULL) {
  355.     return NULL;
  356.     }
  357.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  358.     if (cmdPtr->proc != InterpProc) {
  359.     return NULL;
  360.     }
  361.     return (Proc *) cmdPtr->clientData;
  362. }
  363.  
  364. /*
  365.  *----------------------------------------------------------------------
  366.  *
  367.  * TclIsProc --
  368.  *
  369.  *    Tells whether a command is a Tcl procedure or not.
  370.  *
  371.  * Results:
  372.  *    If the given command is actuall a Tcl procedure, the
  373.  *    return value is the address of the record describing
  374.  *    the procedure.  Otherwise the return value is 0.
  375.  *
  376.  * Side effects:
  377.  *    None.
  378.  *
  379.  *----------------------------------------------------------------------
  380.  */
  381.  
  382. Proc *
  383. TclIsProc(cmdPtr)
  384.     Command *cmdPtr;        /* Command to test. */
  385. {
  386.     if (cmdPtr->proc == InterpProc) {
  387.     return (Proc *) cmdPtr->clientData;
  388.     }
  389.     return (Proc *) 0;
  390. }
  391.  
  392. /*
  393.  *----------------------------------------------------------------------
  394.  *
  395.  * InterpProc --
  396.  *
  397.  *    When a Tcl procedure gets invoked, this routine gets invoked
  398.  *    to interpret the procedure.
  399.  *
  400.  * Results:
  401.  *    A standard Tcl result value, usually TCL_OK.
  402.  *
  403.  * Side effects:
  404.  *    Depends on the commands in the procedure.
  405.  *
  406.  *----------------------------------------------------------------------
  407.  */
  408.  
  409. static int
  410. InterpProc(clientData, interp, argc, argv)
  411.     ClientData clientData;    /* Record describing procedure to be
  412.                  * interpreted. */
  413.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  414.                  * invoked. */
  415.     int argc;            /* Count of number of arguments to this
  416.                  * procedure. */
  417.     char **argv;        /* Argument values. */
  418. {
  419.     register Proc *procPtr = (Proc *) clientData;
  420.     register Arg *argPtr;
  421.     register Interp *iPtr;
  422.     char **args;
  423.     CallFrame frame;
  424.     char *value;
  425.     int result;
  426.  
  427.     /*
  428.      * Set up a call frame for the new procedure invocation.
  429.      */
  430.  
  431.     iPtr = procPtr->iPtr;
  432.     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
  433.     if (iPtr->varFramePtr != NULL) {
  434.     frame.level = iPtr->varFramePtr->level + 1;
  435.     } else {
  436.     frame.level = 1;
  437.     }
  438.     frame.argc = argc;
  439.     frame.argv = argv;
  440.     frame.callerPtr = iPtr->framePtr;
  441.     frame.callerVarPtr = iPtr->varFramePtr;
  442.     iPtr->framePtr = &frame;
  443.     iPtr->varFramePtr = &frame;
  444.     iPtr->returnCode = TCL_OK;
  445.  
  446.     /*
  447.      * Match the actual arguments against the procedure's formal
  448.      * parameters to compute local variables.
  449.      */
  450.  
  451.     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
  452.         argPtr != NULL;
  453.         argPtr = argPtr->nextPtr, args++, argc--) {
  454.  
  455.     /*
  456.      * Handle the special case of the last formal being "args".  When
  457.      * it occurs, assign it a list consisting of all the remaining
  458.      * actual arguments.
  459.      */
  460.  
  461.     if ((argPtr->nextPtr == NULL)
  462.         && (strcmp(argPtr->name, "args") == 0)) {
  463.         if (argc < 0) {
  464.         argc = 0;
  465.         }
  466.         value = Tcl_Merge(argc, args);
  467.         Tcl_SetVar(interp, argPtr->name, value, 0);
  468.         ckfree(value);
  469.         argc = 0;
  470.         break;
  471.     } else if (argc > 0) {
  472.         value = *args;
  473.     } else if (argPtr->defValue != NULL) {
  474.         value = argPtr->defValue;
  475.     } else {
  476.         Tcl_AppendResult(interp, "no value given for parameter \"",
  477.             argPtr->name, "\" to \"", argv[0], "\"",
  478.             (char *) NULL);
  479.         result = TCL_ERROR;
  480.         goto procDone;
  481.     }
  482.     Tcl_SetVar(interp, argPtr->name, value, 0);
  483.     }
  484.     if (argc > 0) {
  485.     Tcl_AppendResult(interp, "called \"", argv[0],
  486.         "\" with too many arguments", (char *) NULL);
  487.     result = TCL_ERROR;
  488.     goto procDone;
  489.     }
  490.  
  491.     /*
  492.      * Invoke the commands in the procedure's body.
  493.      */
  494.  
  495.     procPtr->refCount++;
  496.     result = Tcl_Eval(interp, procPtr->command);
  497.     procPtr->refCount--;
  498.     if (procPtr->refCount <= 0) {
  499.     CleanupProc(procPtr);
  500.     }
  501.     if (result == TCL_RETURN) {
  502.     result = iPtr->returnCode;
  503.     iPtr->returnCode = TCL_OK;
  504.     if (result == TCL_ERROR) {
  505.         Tcl_SetVar2(interp, "errorCode", (char *) NULL,
  506.             (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
  507.             TCL_GLOBAL_ONLY);
  508.         iPtr->flags |= ERROR_CODE_SET;
  509.         if (iPtr->errorInfo != NULL) {
  510.         Tcl_SetVar2(interp, "errorInfo", (char *) NULL,
  511.             iPtr->errorInfo, TCL_GLOBAL_ONLY);
  512.         iPtr->flags |= ERR_IN_PROGRESS;
  513.         }
  514.     }
  515.     } else if (result == TCL_ERROR) {
  516.     char msg[100];
  517.  
  518.     /*
  519.      * Record information telling where the error occurred.
  520.      */
  521.  
  522.     sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
  523.         iPtr->errorLine);
  524.     Tcl_AddErrorInfo(interp, msg);
  525.     } else if (result == TCL_BREAK) {
  526.     iPtr->result = "invoked \"break\" outside of a loop";
  527.     result = TCL_ERROR;
  528.     } else if (result == TCL_CONTINUE) {
  529.     iPtr->result = "invoked \"continue\" outside of a loop";
  530.     result = TCL_ERROR;
  531.     }
  532.  
  533.     /*
  534.      * Delete the call frame for this procedure invocation (it's
  535.      * important to remove the call frame from the interpreter
  536.      * before deleting it, so that traces invoked during the
  537.      * deletion don't see the partially-deleted frame).
  538.      */
  539.  
  540.     procDone:
  541.     iPtr->framePtr = frame.callerPtr;
  542.     iPtr->varFramePtr = frame.callerVarPtr;
  543.  
  544.     /*
  545.      * The check below is a hack.  The problem is that there could be
  546.      * unset traces on the variables, which cause scripts to be evaluated.
  547.      * This will clear the ERR_IN_PROGRESS flag, losing stack trace
  548.      * information if the procedure was exiting with an error.  The
  549.      * code below preserves the flag.  Unfortunately, that isn't
  550.      * really enough:  we really should preserve the errorInfo variable
  551.      * too (otherwise a nested error in the trace script will trash
  552.      * errorInfo).  What's really needed is a general-purpose
  553.      * mechanism for saving and restoring interpreter state.
  554.      */
  555.  
  556.     if (iPtr->flags & ERR_IN_PROGRESS) {
  557.     TclDeleteVars(iPtr, &frame.varTable);
  558.     iPtr->flags |= ERR_IN_PROGRESS;
  559.     } else {
  560.     TclDeleteVars(iPtr, &frame.varTable);
  561.     }
  562.     return result;
  563. }
  564.  
  565. /*
  566.  *----------------------------------------------------------------------
  567.  *
  568.  * ProcDeleteProc --
  569.  *
  570.  *    This procedure is invoked just before a command procedure is
  571.  *    removed from an interpreter.  Its job is to release all the
  572.  *    resources allocated to the procedure.
  573.  *
  574.  * Results:
  575.  *    None.
  576.  *
  577.  * Side effects:
  578.  *    Memory gets freed, unless the procedure is actively being
  579.  *    executed.  In this case the cleanup is delayed until the
  580.  *    last call to the current procedure completes.
  581.  *
  582.  *----------------------------------------------------------------------
  583.  */
  584.  
  585. static void
  586. ProcDeleteProc(clientData)
  587.     ClientData clientData;        /* Procedure to be deleted. */
  588. {
  589.     Proc *procPtr = (Proc *) clientData;
  590.  
  591.     procPtr->refCount--;
  592.     if (procPtr->refCount <= 0) {
  593.     CleanupProc(procPtr);
  594.     }
  595. }
  596.  
  597. /*
  598.  *----------------------------------------------------------------------
  599.  *
  600.  * CleanupProc --
  601.  *
  602.  *    This procedure does all the real work of freeing up a Proc
  603.  *    structure.  It's called only when the structure's reference
  604.  *    count becomes zero.
  605.  *
  606.  * Results:
  607.  *    None.
  608.  *
  609.  * Side effects:
  610.  *    Memory gets freed.
  611.  *
  612.  *----------------------------------------------------------------------
  613.  */
  614.  
  615. static void
  616. CleanupProc(procPtr)
  617.     register Proc *procPtr;        /* Procedure to be deleted. */
  618. {
  619.     register Arg *argPtr;
  620.  
  621.     ckfree((char *) procPtr->command);
  622.     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
  623.     Arg *nextPtr = argPtr->nextPtr;
  624.  
  625.     ckfree((char *) argPtr);
  626.     argPtr = nextPtr;
  627.     }
  628.     ckfree((char *) procPtr);
  629. }
  630.